home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / ASM / STRING.ASM < prev    next >
Encoding:
Assembly Source File  |  1992-11-18  |  11.1 KB  |  437 lines
  1. ;* STRING.ASM
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Borland TASM code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*        String & Char operations (interpreter support)        *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: John Jensen        Date: 1985            *
  16. ;* Revision history:                            *
  17. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18. ;* - 23 Aug 92: Added accented char up-dowcase support (lb)        *
  19. ;*                                    *
  20. ;*                    ``In nomine omnipotentii dei''    *
  21. ;************************************************************************
  22. IDEAL
  23. %PAGESIZE    60, 132
  24. MODEL    small
  25. LOCALS    @@
  26.  
  27.     INCLUDE    "scheme.ash"
  28.     INCLUDE "interprt.ash"
  29.  
  30. DATASEG
  31. ; Case tables (for characters between 40h and 0bfh)
  32.  
  33. LABEL    locases    BYTE
  34. CHAR = 0
  35. REPT    100h
  36. IF    (CHAR GE 'A') AND (CHAR LE 'Z')
  37.     DB    CHAR+'a'-'A'
  38. ELSEIF    CHAR EQ 128            ; \c{C}
  39.     DB    135
  40. ELSEIF    CHAR EQ 142            ; \"A
  41.     DB    132
  42. ELSEIF    CHAR EQ 143            ; \o{A}
  43.     DB    134
  44. ELSEIF    CHAR EQ 144            ; \'E
  45.     DB    130
  46. ELSEIF    CHAR EQ 146            ; \AE
  47.     DB    145
  48. ELSEIF    CHAR EQ 153            ; \"O
  49.     DB    148
  50. ELSEIF    CHAR EQ 154            ; \"U
  51.     DB    129
  52. ELSEIF    CHAR EQ 165            ; \~N
  53.     DB    164
  54. ELSE
  55.     DB    CHAR
  56. ENDIF
  57. CHAR = CHAR+1
  58. ENDM
  59.  
  60. LABEL    hicases    BYTE
  61. CHAR = 0
  62. REPT    100h
  63. IF    (CHAR GE 'a') AND (CHAR LE 'z')
  64.     DB    CHAR+'A'-'a'
  65. ELSEIF    CHAR EQ 129            ; \"u
  66.     DB    154
  67. ELSEIF    CHAR EQ 130            ; \'e
  68.     DB    144
  69. ELSEIF    CHAR EQ 132            ; \"a
  70.     DB    142
  71. ELSEIF    CHAR EQ 134            ; \o{a}
  72.     DB    143
  73. ELSEIF    CHAR EQ 135            ; \c{c}
  74.     DB    128
  75. ELSEIF    CHAR EQ 145            ; \ae
  76.     DB    146
  77. ELSEIF    CHAR EQ 148            ; \"o
  78.     DB    153
  79. ELSEIF    CHAR EQ 164            ; \~n
  80.     DB    165
  81. ELSE
  82.     DB    CHAR
  83. ENDIF
  84. CHAR = CHAR+1
  85. ENDM
  86.  
  87. CODESEG
  88. ;************************************************************************
  89. ;            Char comparisons                *
  90. ;************************************************************************
  91. MACRO    charcmp    comparison, case
  92.     LOCAL    @@satisfied
  93.     get2op
  94.     xor    bx, bx
  95.     mov    bl, al
  96.     lea    di, [regs+bx]
  97.     mov    bl, ah
  98.     add    bx, OFFSET regs
  99.     mov    al, [(REG bx).bpage]
  100.     cmp    al, SPECCHAR*2        ; are sources a characters?
  101.     jne    @@error
  102.     cmp    al, [(REG di).bpage]
  103.     jne    @@error
  104. IFIDN    <case>, <INSENSITIVE>
  105.     mov    al, [BYTE (REG bx).disp]
  106.     lea    bx, [locases]        ; Fetch lower-case equivalents
  107.     xlat
  108.     mov    ah, al
  109.     mov    al, [BYTE (REG di).disp]
  110.     xlat
  111. ELSE
  112.     mov    al, [BYTE (REG di).disp]
  113.     mov    ah, [BYTE (REG bx).disp]
  114. ENDIF
  115.     cmp    al, ah
  116.     j&comparison    @@satisfied
  117.     xor    ax, ax            ; place 'nil in destination reg
  118.     mov    [(REG di).bpage], al
  119.     mov    [(REG di).disp], ax
  120.     jmp    next
  121. @@satisfied:
  122.     mov    [(REG di).bpage], T_PAGE*2 ; place 't in dest. reg
  123.     mov    [(REG di).disp], T_DISP
  124.     jmp    next
  125. ENDM
  126.  
  127. ;************************************************************************
  128. ;*                            al    ah    *
  129. ;* (char-= char1 char2)                char-=    dest,    src    *
  130. ;*                                    *
  131. ;* Purpose: Scheme interpreter support for comparing the equality of    *
  132. ;*        character data objects.                    *
  133. ;*                                    *
  134. ;* Description: The tags (page numbers) or the objects are compared    *
  135. ;*        for equality. If they are not equal, at least one of    *
  136. ;*        the operands is not a character, and an error is    *
  137. ;*        signaled. If they are equal, a second check to make    *
  138. ;*        sure both are characters is performed.            *
  139. ;*                                    *
  140. ;*        After validating the tag fields, the displacement fields*
  141. ;*        are compared for equality. If they are identical, the    *
  142. ;*        characters are equal and 't is returned in the destina- *
  143. ;*        tion register.    If not equal, 'nil is returned in the    *
  144. ;*        destination register.                    *
  145. ;************************************************************************
  146. PROC    ch_eq_p
  147.     charcmp    e
  148. @@error:
  149.     lea    ax, [@@msg]
  150. DATASEG
  151. @@msg    DB    "CHAR=?", 0
  152. CODESEG
  153. in_ch_eq_p:
  154.     add    bx, OFFSET regs        ; compute address of source 2
  155.     mov    cx, 2
  156.     call    set_src_error C, ax, cx, di, bx
  157.     jmp    sch_err            ; link to Scheme debugger
  158. ENDP
  159.  
  160. ;************************************************************************
  161. ;*                            al    ah    *
  162. ;* (char-equal? char1 char2)        char-eq?    dest,    src    *
  163. ;*                                    *
  164. ;* Purpose: Scheme interpreter support for comparing the equality of    *
  165. ;*        character data objects ignoring case.            *
  166. ;*                                    *
  167. ;* Description:    The tags (page numbers) or the objects are compared    *
  168. ;*        for equality. If they are not equal, at least one of    *
  169. ;*        the operands is not a character, and an error is    *
  170. ;*        signaled. If they are equal, a second check to make    *
  171. ;*        sure both are characters is performed.            *
  172. ;*                                    *
  173. ;*        The displacements of both operands are loaded and    *
  174. ;*        mapped to uppercase. They are then compared for        *
  175. ;*        equality. If equal, 't is returned in the destination    *
  176. ;*        registers. Otherwise, 'nil is returned.            *
  177. ;************************************************************************
  178. PROC    ch_eq_ci
  179.     charcmp    e, INSENSITIVE
  180. @@error:
  181.     lea    ax, [@@msg]
  182. DATASEG
  183. @@msg    DB    "CHAR-CI=?", 0
  184. CODESEG
  185.     jmp    in_ch_eq_p
  186. ENDP
  187.  
  188. ;************************************************************************
  189. ;*                            al    ah    *
  190. ;* (char-< char1 char2)                char-<    dest,    src    *
  191. ;************************************************************************
  192. PROC    ch_lt_p
  193.     charcmp b, cs, m_ch_lt
  194. @@error:
  195.     lea    ax, [@@msg]
  196. DATASEG
  197. @@msg    DB    "CHAR<?", 0
  198. CODESEG
  199.     jmp    in_ch_eq_p
  200. ENDP
  201.  
  202. ;************************************************************************
  203. ;*                            al    ah    *
  204. ;* (char-less? char1 char2)        char-less?    dest,    src    *
  205. ;************************************************************************
  206. PROC    ch_lt_ci
  207.     charcmp b, INSENSITIVE
  208. @@error:
  209.     lea    ax, [@@msg]
  210. DATASEG
  211. @@msg    DB    "CHAR-CI<?", 0
  212. CODESEG
  213.     jmp    in_ch_eq_p
  214. ENDP
  215.  
  216. ;************************************************************************
  217. ;*                Char cases                *
  218. ;************************************************************************
  219. MACRO    ch_case    direction
  220.     get1op
  221.     mov    di, ax
  222.     add    di, OFFSET regs
  223.     cmp    [(REG di).bpage], SPECCHAR*2
  224.     jne    @@error
  225.     mov    al, [BYTE (REG di).disp]
  226.     lea    bx, [direction]
  227.     xlat
  228.     mov    [BYTE (REG di).disp], al
  229.     jmp    next
  230. ENDM
  231.  
  232. ;************************************************************************
  233. ;*                                al    *
  234. ;* (char-upcase char)                char-upcase    dest    *
  235. ;*                                    *
  236. ;* Purpose: Scheme interpreter support for conversion of characters    *
  237. ;*        to uppercase                        *
  238. ;************************************************************************
  239. PROC    ch_up
  240.     ch_case    hicases
  241. @@error:
  242.     lea    ax, [@@msg]
  243. DATASEG
  244. @@msg    DB    "CHAR-UPCASE", 0
  245. CODESEG
  246. in_ch_up:
  247.     mov    cx, 1
  248.     call    set_src_error C, ax, cx, di
  249.     jmp    sch_err
  250. ENDP
  251.  
  252. ;************************************************************************
  253. ;*                                    al    *
  254. ;* (char-downcase char)            char-downcase        dest    *
  255. ;*                                    *
  256. ;* Purpose: Scheme interpreter support for conversion of characters    *
  257. ;*        to lowercase                        *
  258. ;************************************************************************
  259. PROC    ch_down
  260.     ch_case locases
  261. @@error:
  262.     lea    ax, [@@msg]
  263. DATASEG
  264. @@msg    DB    "CHAR-DOWNCASE", 0
  265. CODESEG
  266.     jmp    in_ch_up
  267. ENDP
  268.  
  269. ;************************************************************************
  270. ;*                                al    ah    *
  271. ;* (make-string len init)        make-string    len,    init    *
  272. ;************************************************************************
  273. PROC    make_str
  274.     get2op
  275.     save    <si>
  276.     xor    bx, bx
  277.     mov    bl, al
  278.     add    bx, OFFSET regs
  279.     cmp    [(REG bx).bpage], SPECFIX*2
  280.     jne    @@error
  281.     mov    cx, [(REG bx).disp]
  282.     or    cx, cx
  283.     jl    @@error            ; if size is negative, error
  284.     mov    dx, STRTYPE
  285.     push    ax bx            ; preserve init-reg, dest-reg
  286.     call    alloc_block C, bx, dx, cx
  287.     pop    bx ax
  288.     mov    di, [(REG bx).disp]
  289.     mov    bx, [(REG bx).page]
  290.     ldpage    es, bx
  291.     mov    bl, ah
  292.     mov    al, [regs+bx.bpage]
  293.     cmp    al, SPECCHAR*2        ; init value a character?
  294.     je    str_fill_load
  295.     cmp    al, NIL_PAGE*2        ; use default value? (nil?)
  296.     jne    @@error
  297.     mov    al, ' '
  298.     jmp    str_fill_loaded
  299. @@error:
  300.     lea    bx, [@@msg]
  301. DATASEG
  302. @@msg    DB    "MAKE-STRING", 0
  303. CODESEG
  304.     jmp    src_err
  305. ENDP    make_str
  306.  
  307. ;************************************************************************
  308. ;*                            al    ah    *
  309. ;* (string-fill! string char)        string-fill!    str,    char    *
  310. ;************************************************************************
  311. PROC    str_fill
  312.     get2op
  313.     save    <si>
  314.     xor    bx, bx
  315.     mov    bl, al
  316.     mov    di, bx
  317.     mov    bl, [regs+di.bpage]
  318.     cmp    [ptype+bx], STRTYPE
  319.     jne    @@error
  320.     ldpage    es, bx
  321.     mov    di, [regs+di.disp]
  322.     mov    bl, ah            ; copy initialization value register number
  323.     cmp    [regs+bx.page], SPECCHAR*2
  324.     jne    @@error
  325. str_fill_load:
  326.     mov    al, [BYTE regs+bx.disp]; load initialization character
  327. str_fill_loaded:
  328.     mov    cx, [(STRDEF es:di).len]
  329.     or    cx, cx
  330.     jge    @@bigstring
  331.     add    cx, OFFSET (TYPE STRDEF).buffer + SIZE POINTER
  332. @@bigstring:
  333.     sub    cx, OFFSET (TYPE STRDEF).buffer
  334.     add    di, OFFSET (TYPE STRDEF).buffer
  335.     rep    stosb
  336.     jmp    next_pc
  337. @@error:
  338.     lea    bx, [@@msg]
  339. DATASEG
  340. @@msg    DB    "FILL-STRING!", 0
  341. CODESEG
  342.     jmp    src_err
  343. ENDP    str_fill
  344.  
  345. ;************************************************************************
  346. ;*        Macro Support for String ref/set            *
  347. ;************************************************************************
  348. MACRO    strch    ref_or_set
  349.     local    @@bigstring
  350.     get2op
  351.     xor    bx, bx
  352.     mov    bl, al        ; copy string/dest reg number into di
  353.     lea    di, [regs+bx]
  354. IFIDN    <ref_or_set>, <SET>
  355.     get1op
  356.     mov    dl, al        ; save datum in dl
  357. ENDIF
  358.     save    <si>
  359.     mov    bl, [(REG di).bpage]
  360.     cmp    [ptype+bx], STRTYPE
  361.     jne    @@error
  362.     ldpage    es, bx
  363.     mov    bl, ah        ; copy index register number
  364.     cmp    [regs+bx.bpage], SPECFIX*2
  365.     jne    @@error
  366.     mov    bx, [regs+bx.disp]
  367.     or    bx, bx
  368.     jl    @@badnumber
  369.     mov    si, [(REG di).disp]
  370.     mov    cx, [(STRDEF es:si).len]
  371.     or    cx, cx
  372.     jge    @@bigstring
  373.     add    cx, OFFSET (TYPE STRDEF).buffer + SIZE POINTER
  374. @@bigstring:
  375.     add    bx, OFFSET (TYPE STRDEF).buffer
  376.     cmp    bx, cx
  377.     jge    @@badnumber
  378. ENDM
  379.  
  380. ;************************************************************************
  381. ;*                            al    ah    *
  382. ;* (string-ref string index)        string-ref    str,    index    *
  383. ;************************************************************************
  384. PROC    st_ref
  385.     strch    REF
  386.     mov    [(REG di).bpage], SPECCHAR*2
  387.     mov    bl, [BYTE es:si+bx]
  388.     xor    bh, bh
  389.     mov    [(REG di).disp], bx
  390.     jmp    next_pc
  391. @@error:
  392.     lea    bx, [@@msg]
  393. DATASEG
  394. @@msg    DB    "STRING-REF", 0
  395. CODESEG
  396.     jmp    src_err
  397. @@badnumber:
  398.     lea    bx, [@@msg]
  399.     mov    dx, 3        ; STRING-REF is 3 bytes long
  400. in_st_ref:
  401.     restore <si>        ; load location pointer and
  402.     sub    si, dx        ; back up to start of instruction in error
  403.     call    disassemble C, bx, si
  404.     mov    cx, 1
  405.     mov    dx, STRING_OFFSET_ERROR
  406.     call    set_numeric_error C, cx, dx, [tmp_adr]
  407.     restore <si>
  408.     jmp    sch_err
  409. ENDP
  410.  
  411. ;************************************************************************
  412. ;*                        al    ah    al    *
  413. ;* (string-set! string index char) string-set!    str,    index,    char    *
  414. ;************************************************************************
  415. PROC    st_set
  416.     strch    SET
  417.     xor    dh, dh
  418.     mov    di, dx        ; copy source value register number
  419.     cmp    [regs+di.bpage], SPECCHAR*2
  420.     jne    @@error
  421.     mov    al, [BYTE regs+di.disp]
  422.     mov    [BYTE es:si+bx], al
  423.     jmp    next_pc
  424. @@error:
  425.     lea    bx, [@@msg]
  426. DATASEG
  427. @@msg    DB    "STRING-SET!", 0
  428. CODESEG
  429.     jmp    src_err
  430. @@badnumber:
  431.     lea    bx, [@@msg]
  432.     mov    dx, 4        ; STRING-SET! is 4 bytes long
  433.     jmp    in_st_ref
  434. ENDP
  435.  
  436.     END
  437.